;;;
;;; This file is part of scheme-x-interface.
;;;
;;; scheme-x-interface is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; scheme-x-interface is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with scheme-x-interface.  If not, see <http://www.gnu.org/licenses/>.
;;;


(library
 (sxi)
 (export)
 (import (for (rnrs base (6)) run expand)
	 (rnrs bytevectors (6))
	 (rnrs io ports (6))
	 (rnrs io simple (6))
	 (for (rnrs syntax-case (6)) run expand)
	 (xsb impl-dep plt socket))

 (define-syntax if-little-endian
   (syntax-rules ()
     ([_ li bi] (if (symbol=? 'little (native-endianness))
			 li
			 bi))))

 (define TODO-implement 'TODO-implement)

 ;;let-input
 ;;used internaly to make reading input to variables easier
 
 (define-syntax let-input
   (lambda (x)
     (define expand
       (lambda (port formals)
	 (let loop ([remaining formals]
		    [ret '()])
	   (loop
	    (cdr remaining)
	    (append ret (let* ([curr (car remaining)]
			       [name (car curr)]
			       [type (cadr curr)])
			  (list
			   name
			   (case (car type)
			     ([_int] 
			      (if (= 1 (length (cdr type)))
				  `(get-int ,(cadr type))))
			     ([_uint] 
			      (if (= 1 (length (cdr type)))
				  `(get-uint ,(cadr type))))
			     ([_string]
			      'TODO-implement
			      #;
			      (case (length (cdr type))
				([0])
				([1]
				 `(get-bytevector))
				(else)))
			     ([_vector]
			      'TODO-implement)
			     ([_list]
			      'TODO-implement)
			     ([_record]
			      'TODO-implement)))))))))
     (syntax-case x ()
       [(_ port formals body) 
	#`(let* #,(expand #'port (syntax->datum #'formals)) body)])))

 ;;
 ;;write-format
 ;;
 ;;(write-format <port> <format> ...)
 ;;
 ;;format
 ;;
 ;;(<type> <value>)
 ;;
 ;;type
 ;;
 ;;signed integers
 ;;(_int size)
 ;;unsigned integers
 ;;(_uint size)
 ;;string
 ;;(_string start length)
 ;;(_vector start length <type>)
 ;;(_list length <type>)
 ;;(_record)
 ;;misc
 ;;(_ignore length)
 ;;

 (define-syntax write-bytes-format
   (lambda (x)
     (syntax-case x ()
       [(_ port fmt ... )
	(let ([wrong-number-of-args (lambda ()
				      #'TODO-implement)])
	  (let loop ([remaining (syntax->datum #'(fmt ...))]
		     [ret '()]
		     [ignore '(+)])
	    (if (= (length remaining) 0)
		;;finish
		(if (= 1 (length ignore))
		    #`(begin #,@ret)
		    #`(begin #,@ret
			     (put-bytevector #,port
					     (make-bytevector #,ignore 0)))
		(let ([curr-args (cadr remaining)]
		      [format (caar remaining)])
		  (if (symbol=? format '_ignore)
		      ;;add bytes to ignore
		      (if (= (length curr-args) 1)
			  (loop (cdr remaining) 
				ret
				(append ignore (car curr-args)))
			  (wrong-number-of-args))
		      (loop (cdr remaining)
			    (append ret 
				    (append 
				     (if (= 1 (length ignore))
					 '()
       					 `(begin
					    (put-bytevector ,port 
							    (make-bytevector 
							     ,ignore 
							     0))))
				     (case format
				       ([_int]
					(if (= (length curr-args) 1)
					    '(put-int ,@curr-args))
					(wrong-number-of-args))
				       ([_uint]
					(if (= (length curr-args) 1)
					    '(put-uint ,@curr-args))
					(wrong-number-of-args))
				       ([_string]
					'TODO-implement)
				       ([_vector]
					'TODO-implement)
				       ;;list and record might need some 
				       ;;special work as they are 
				       ;;non-homologous structures
				       ([_list]
					'TODO-implement)
				       ([_record]
					'TODO-implement))))
			    0)))))))])))

 (define X-PROTOCOL-VERSION '(11 . 0))

 (define x-success:failed 0)
 (define x-success:success 1)
 (define x-success:auth-required 2)

 (define get-u16
   (lambda (port)
     'TODO-implement))

 (define put-u16
   (lambda (port val)
     (call-with-values (lambda () (div-and-mod val #xFF))
       (lambda (h l) 
	 (do-endian (begin (put-u8 port l) (put-u8 port h))
		    (begin (put-u8 port h) (put-u8 port l)))))))

 (define-record-type (<display> make-display display)
   (fields
    major-version
    minor-version
    release-number
    resource-id-base
    resource-id-mask
    motion-buffer-size
    maximum-request-length
    image-byteorder
    bitmap-bitorder
    bitmap-scanline-unit
    bitmap-scanline-pad
    min-keycode
    max-keycode
    vendor
    pixmap-formats
    roots))

 (define connection-success
   (lambda (port)
     
     (get-u8 port);;ignored
     (let-input port ([major-version (_uint 2)]
		      [minor-version (_uint 2)]
		      [data-size (_uint 2)]
		      [release-number (_uint 4)]
		      [resource-id-base (_uint 4)]
		      [resource-id-mask (_uint 4)]
		      [motion-buffer-size (_uint 4)]
		      [vendor-length (_uint 2)]
		      [maximum-request-length (_uint 2)]
		      [roots-length (_uint 1)]
		      [pixmap-formats-length (_uint 1)]
		      [image-byteorder (_uint 1)]
		      [bitmap-bitorder (_uint 1)]
		      [bitmap-scanline-unit (_uint 1)]
		      [bitmap-scanline-pad (_uint 1)]
		      [min-keycode (_uint 1)]
		      [max-keycode (_uint 1)]
		      [ignored (_uint 4)]
		      [vendor (_string vendor-length)]
		      [ignored2 (_uint (- 4 (mod vendor-length 4)))]
		      #;
		      ;; to be finished
		      [pixmap-formats (_list pixmap-format-length
					     (_record pixmap-format))])
		'TODO-implement)))

 (define init-x-connection
   (lambda (port)
     (write-bytes-format 
      port
      ([_uint 1] (if-little-endian #x6C #x42))
      ([_ignore 1]);;unused
      ([_uint 2] (car X-PROTOCOL-VERSION))
      ([_uint 2] (cdr X-PROTOCOL-VERSION))
      ;;no authentication support yet
      ([_uint 2] 0)
      ([_uint 2] 0)
      ([_uint 2] 0))
     (flush-output-port port)
     (case (get-u8 p)
       ([x-success:failed]
	)
       ([x-success:success]
	(connection-success port))
       ([x-success:auth-required]
	))
     ))
)
